home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / 6.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  38.1 KB  |  1,328 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #include "hdr.h"
  11. #include "libhdr.h"
  12. #include "vars.h"
  13. #include "setprots.h"
  14. #include "dclmapprots.h"
  15. #include "errmsgprots.h"
  16. #include "miscprots.h"
  17. #include "smiscprots.h"
  18. #include "nodesprots.h"
  19. #include "utilprots.h"
  20. #include "chapprots.h"
  21. #include "libprots.h"
  22.  
  23. static void invisible_designator(Node, char *);
  24. static Tuple derived_formals(Symbol, Tuple);
  25. static void proc_or_entry(Node);
  26. static void new_over_spec(Symbol, int, Symbol, Tuple, Symbol, Node);
  27.  
  28. void subprog_decl(Node node)  /*;subprog_decl*/
  29. {
  30.     Node    spec_node, id_node, neq_node, eq_node;
  31.     Symbol    subp_name, neq;
  32.     int        exists;
  33.     Forset    fs1;
  34.  
  35.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  subprog_decl");
  36.  
  37.     spec_node = N_AST1(node);
  38.     id_node = N_AST1(spec_node);
  39.     new_compunit("ss", id_node);
  40.     adasem(spec_node);
  41.     check_spec(node);
  42.  
  43.     subp_name = N_UNQ(id_node);
  44.     save_subprog_info(subp_name);
  45.  
  46.     /* Modify the node kind for subprogram declarations to be 
  47.      * as_subprogram_decl_tr so that their specification part need not be 
  48.      * saved in the tree automatically. The formal part will be saved by 
  49.      * collect_unit_nodes only in the case of a subprogram specification 
  50.      * that is not in the same unit as the body as it is then needed for 
  51.      * conformance checks. In addition the node as_procedure (as_function)
  52.      * is no longer needed in the tree since this info is obtained from
  53.      * the symbol table.
  54.      * Since the spec  part is now dropped we now move the id_node info 
  55.      * (name of the subprogram) to the N_UNQ filed of the as_subprogram_decl_tr
  56.      * node directly.
  57.      */
  58.  
  59.     N_KIND(node) = as_subprogram_decl_tr;
  60.     N_UNQ(node) = N_UNQ(id_node);
  61.     if (streq(N_VAL(id_node) , "=") &&  tup_size(SIGNATURE(subp_name)) == 2) {
  62.         /* build tree for declaration of inequality that was just introduced 
  63.          * (in the current scope, or the enclosing one, if now in private part).
  64.          */
  65.         exists = FALSE;
  66.         FORSET(neq = (Symbol), OVERLOADS(dcl_get(DECLARED(SCOPE_OF(subp_name)),
  67.           "/=")), fs1);
  68.             if ( same_signature(neq, subp_name) ) {
  69.                 exists = TRUE;
  70.                 break;
  71.             }
  72.         ENDFORSET(fs1);
  73.         if (exists) {
  74.             neq_node = copy_tree(node);          /* a valid subprogram decl*/
  75.             N_UNQ(neq_node) = neq;
  76.             eq_node = copy_node(node);
  77.             make_insert_node(node, tup_new1((char *) eq_node), neq_node);
  78.         }
  79.     }
  80. }
  81.  
  82. void check_spec(Node node) /*;check_spec*/
  83. {
  84.     /* If the subprogram name is an     operator designator, verify that it has
  85.      * the proper type and number of arguments.
  86.      */
  87.  
  88.     int        proc_nat;
  89.     Node    spec_node, id_node, formal_node, ret_node;
  90.     char    *proc_id;
  91.     Tuple    formals;
  92.     Symbol    ret;
  93.     Symbol    prog_name;
  94.     int        spec_kind, node_kind;
  95.  
  96.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  check_spec ");
  97.  
  98.     spec_node = N_AST1(node);
  99.     id_node = N_AST1(spec_node);
  100.     formal_node = N_AST2(spec_node);
  101.     ret_node = N_AST3(spec_node);
  102.     proc_id = N_VAL(id_node);
  103.  
  104.     spec_kind = N_KIND(spec_node);
  105.     if (spec_kind == as_procedure)
  106.         ret = symbol_none;
  107.     else
  108.         ret = N_UNQ(ret_node);
  109.  
  110.     switch (node_kind = N_KIND(node)) {
  111.       case    as_subprogram_decl:
  112.                 if (spec_kind == as_procedure)
  113.                     proc_nat = na_procedure_spec;
  114.                 else
  115.                     proc_nat = na_function_spec;
  116.                 break;
  117.       case    as_subprogram:
  118.       case    as_subprogram_stub:
  119.       case    as_generic_subp:
  120.                 if (spec_kind == as_procedure)
  121.                     proc_nat = na_procedure;
  122.                 else
  123.                     proc_nat = na_function;
  124.                 break;
  125.     }
  126.  
  127.     formals = get_formals(formal_node, proc_id);
  128.  
  129.     check_out_parameters(formals);
  130.  
  131.     if (in_op_designators(proc_id ))
  132.         check_new_op(id_node, formals, ret);
  133.  
  134.     prog_name = chain_overloads(proc_id, proc_nat, ret, formals, (Symbol)0,
  135.       formal_node);
  136.     N_UNQ(id_node) = prog_name;
  137. }
  138.  
  139. void check_new_op(Node id_node, Tuple formals, Symbol ret)    /*;check_new_op */
  140. {
  141.     /* apply special checks for definition of operators */
  142.     char *proc_id;
  143.     Tuple tup;
  144.     Fortup ft1;
  145.     Node  initv;
  146.     int  exists;
  147.     Symbol typ1;
  148.  
  149.     proc_id = N_VAL(id_node);
  150.  
  151.     if ((strcmp(proc_id , "+") == 0 || strcmp(proc_id, "-") == 0)
  152.       && tup_size(formals) == 1)
  153.         ;    /* Unary operators.*/
  154.     else if ( (strcmp(proc_id , "not") == 0 || strcmp(proc_id, "abs") == 0)
  155.       ? tup_size(formals) == 1 : tup_size(formals) == 2 )
  156.         ;
  157.     else {
  158. #ifdef ERRNUM
  159.         str_errmsgn(373, proc_id, 54, id_node);
  160. #else
  161.         errmsg_str("Incorrect no. of arguments for operator %" , proc_id,
  162.           "6.7", id_node);
  163. #endif
  164.     }
  165.  
  166.     exists = FALSE;
  167.     FORTUP(tup = (Tuple), formals, ft1);
  168.         initv = (Node)tup[4];
  169.         if (initv != OPT_NODE) {
  170.             exists = TRUE;
  171.             break;
  172.         }
  173.     ENDFORTUP(ft1);
  174.     if (exists) {
  175. #ifdef ERRNUM
  176.         errmsgn(53, 54, initv);
  177. #else
  178.         errmsg("Initializations not allowed for operators", "6.7", initv);
  179. #endif
  180.     }
  181.     /* Apply the special checks on redefinitions of equality.*/
  182.     else if (streq(proc_id , "=")) {
  183.         typ1 = (Symbol) ((Tuple)formals[1])[3];    /* type of formal*/
  184.         if (tup_size(formals) != 2
  185.           || typ1 != (Symbol) ((Tuple)formals[2])[3] 
  186.           || ret != symbol_boolean) {
  187. #ifdef ERRNUM
  188.             errmsgn(374, 54, id_node);
  189. #else
  190.             errmsg("Invalid argument profile for \"=\"", "6.7", id_node);
  191. #endif
  192.         }
  193.     }
  194.     else if (strcmp(proc_id , "/=") == 0) {
  195. #ifdef ERRNUM
  196.         errmsgn(375, 54, id_node);
  197. #else
  198.         errmsg(" /=     cannot be given an explicit definition", "6.7", id_node);
  199. #endif
  200.     }
  201. } /* end check_new_op */
  202.  
  203. Tuple get_formals(Node formal_list, char *proc_id)             /*;get_formals*/
  204. {
  205.     /* Utility to format the formals of a subprogram specification, in the
  206.      * internal form kept in  the subprogram's signature.
  207.      */
  208.  
  209.     Node    formal_node, id_list, m_node, type_node, exp_node, id_node;
  210.     Tuple    formals, tup;
  211.     Fortup    ft1, ft2;
  212.     int        formal_index, f_mode;
  213.     Symbol     type_mark;
  214.  
  215.     formal_index = 0;
  216.     FORTUP(formal_node = (Node), N_LIST(formal_list), ft1);
  217.         id_list = N_AST1(formal_node);
  218.         FORTUP(id_node = (Node), N_LIST(id_list), ft2);
  219.             formal_index++;
  220.         ENDFORTUP(ft2);
  221.     ENDFORTUP(ft1);
  222.     formals = tup_new(formal_index);
  223.     formal_index = 0;
  224.  
  225.     FORTUP(formal_node = (Node), N_LIST(formal_list), ft1);
  226.         id_list = N_AST1(formal_node);
  227.         m_node = N_AST2(formal_node);
  228.         type_node = N_AST3(formal_node);
  229.         invisible_designator(type_node, proc_id);
  230.         exp_node = N_AST4(formal_node);
  231.         invisible_designator(exp_node, proc_id);
  232.         f_mode = (int) N_VAL(m_node);
  233.         if (f_mode == 0) f_mode = na_in; /* note using 0 for '' f_mode case */
  234.         type_mark = find_type(copy_tree(type_node)); /* for conformance check */
  235.         FORTUP(id_node = (Node), N_LIST(id_list), ft2);
  236.             formal_index++;
  237.             tup = tup_new(4);
  238.             tup[1] = (char *)N_VAL(id_node);
  239.             tup[2] = (char *) f_mode;
  240.             tup[3] = (char *) type_mark;
  241.             tup[4] = (char *) copy_tree(exp_node);
  242.             formals[formal_index] = (char *) tup;
  243.         ENDFORTUP(ft2);
  244.     ENDFORTUP(ft1);
  245.  
  246.     return (formals);
  247. }
  248.  
  249. static void invisible_designator(Node tree_node, char *proc_id)
  250. /*;invisible_designator*/
  251. {
  252.     /*
  253.      * check for premature use of formals
  254.      */
  255.  
  256.     int        nk;
  257.     Node    n;
  258.     Fortup    ft1;
  259.  
  260.     /* The designator of a subprogram is not visible within its specification.*/
  261.  
  262.     nk = N_KIND(tree_node);
  263.     if (N_KIND(tree_node) == as_simple_name)  {
  264.         if (streq(N_VAL(tree_node), proc_id))
  265. #ifdef ERRNUM
  266.             str_errmsgn(425, proc_id, 50, tree_node);
  267. #else
  268.             errmsg_str("premature usage of %", proc_id, "8.3(16)", tree_node);
  269. #endif
  270.     }
  271.     else {
  272.         if (N_AST1_DEFINED(nk)) invisible_designator(N_AST1(tree_node),proc_id);
  273.         if (N_AST2_DEFINED(nk)) invisible_designator(N_AST2(tree_node),proc_id);
  274.         if (N_AST3_DEFINED(nk)) invisible_designator(N_AST3(tree_node),proc_id);
  275.         if (N_AST4_DEFINED(nk)) invisible_designator(N_AST4(tree_node),proc_id);
  276.  
  277.         if (N_LIST_DEFINED(nk) && N_LIST(tree_node) != (Tuple)0) {
  278.             FORTUP(n = (Node), N_LIST(tree_node), ft1);
  279.                 invisible_designator(n, proc_id);
  280.             ENDFORTUP(ft1);
  281.         }
  282.     }
  283. }
  284.  
  285. void subprog_body(Node node)        /*;subprog_body*/
  286. {
  287.     Node    specs_node, id_node, stats_node;
  288.     Node    eq_node, neq_node;
  289.     char    *spec_name, *prog_id;
  290.     Symbol    unname, prog_name, neq, scope;
  291.     int        i;
  292.     Forset    fs1;
  293.     Fortup    ft1;
  294.     int        exists;
  295.     Tuple    decscopes, decmaps, s_info;
  296.     /* s_info may not be needed     ds 30 jul*/
  297.     Unitdecl    ud;
  298.  
  299.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : subprog_body");
  300.  
  301.     specs_node  = N_AST1(node);
  302.  
  303.     id_node = N_AST1(specs_node);
  304.     adasem(id_node);
  305.     prog_id = N_VAL(id_node);
  306.  
  307.     if (IS_COMP_UNIT) {
  308.         new_compunit("su", id_node);
  309.         /* If the specification of the unit was itself a compilation unit, we
  310.          * will verify that the two specs are conforming. If this is the
  311.          * body to a generic comp. unit, will have to access and update the
  312.          * spec. In both cases see if the spec. is available.
  313.          */
  314.         spec_name = strjoin("ss", prog_id);    /* Already retrieved*/
  315.         ud = unit_decl_get(spec_name);
  316.         if (ud != (Unitdecl)0) {
  317.             /* Unpack declarations and install symbol table of unit.
  318.              * [unname, s_info, decmap] := UNIT_DECL(spec_name);
  319.              */
  320.             unname = ud->ud_unam;
  321.             s_info = ud->ud_symbols;
  322.             decscopes = ud->ud_decscopes;
  323.             decmaps = ud->ud_decmaps;
  324.             /* Must look before putting because name could have been 'with'ed */
  325.             if (dcl_get(DECLARED(symbol_standard0), prog_id) != unname)
  326.                 dcl_put(DECLARED(symbol_standard0), prog_id, unname);
  327.  
  328.             /* (for decls = decmap(scope)) declared(scope) := decls; end; */
  329.             FORTUPI(scope = (Symbol), decscopes, i, ft1);
  330.                 if (decmaps[i] != (char *)0)
  331.                     DECLARED(scope) = dcl_copy((Declaredmap) decmaps[i]);
  332.             ENDFORTUP(ft1);
  333.  
  334.             /* TBSL does s_info need to be retored ?? */
  335.             symtab_restore(s_info);
  336.         }
  337.     }
  338.     check_old(id_node);
  339.     prog_name = N_UNQ(id_node);
  340.     if (prog_name != (Symbol)0 
  341.       &&(NATURE(prog_name) == na_generic_procedure_spec 
  342.       || NATURE(prog_name) == na_generic_function_spec)) {
  343.         generic_subprog_body(prog_name, node);
  344.         return;
  345.     }
  346.     else {
  347.         /* (Re)process subprogram specification.*/
  348.         adasem(specs_node);
  349.         check_spec(node);
  350.         prog_name = N_UNQ(id_node);
  351.         if (NATURE(prog_name) !=na_procedure && NATURE(prog_name) !=na_function)
  352.             /* illegal subprogram name or redeclaration */
  353.             return;
  354.  
  355.         if (IS_COMP_UNIT && ud != (Unitdecl)0 && prog_name != unname) {
  356.             /* Spec. does not match its previous occurrence, or several
  357.              * subprograms with same name are present.
  358.              */
  359. #ifdef ERRNUM
  360.             errmsgn(376, 377, id_node);
  361. #else
  362.             errmsg("library subprograms cannot be overloaded",
  363.               "10.1(10)", id_node);
  364. #endif
  365.             return;
  366.         }
  367.     }
  368.     if (!streq(original_name(prog_name), unit_name_name(unit_name))) {
  369.         /*
  370.         * All types in the current declarative part must be forced before
  371.         * entering a nested scope.
  372.         */
  373.         force_all_types();
  374.     }
  375.     newscope(prog_name);
  376.     process_subprog_body(node, prog_name);
  377.     force_all_types();
  378.     popscope();
  379.     save_subprog_info(prog_name);
  380.     /* Modify the node kind for subprogram bodies to be as_subprogram_tr 
  381.      * so that their specfication part need not be saved in the tree 
  382.      * automatically. The formal part need not be saved for the bodies
  383.      * since all the info is in the symbol table and the conformance checks
  384.      * are done against the formal part saved for the specification if any
  385.      * was given.
  386.      * In addition the node as_procedure (as_function) is no longer needed 
  387.      * in the tree since this info is obtained from the symbol table.
  388.      * Since the spec part is now dropped we now move the id_node info 
  389.      * (name of the subprogram) to the N_UNQ filed of the as_subprogram_tr
  390.      * node directly. In order to put the unique name info in the 
  391.      * as_subprogram_tr node we must shift the stats_node (statement part) 
  392.      * from being N_AST3 to N_AST1 so that we can use the N_UNQ field.
  393.      */
  394.     N_KIND(node) = as_subprogram_tr;
  395.     stats_node = N_AST3(node);
  396.     N_AST1(node) = stats_node;
  397.     N_UNQ(node) = N_UNQ(id_node);
  398.  
  399.     if (streq(prog_id , "=")) {
  400.         exists = FALSE;
  401.         FORSET(neq = (Symbol), OVERLOADS(dcl_get(DECLARED(SCOPE_OF(prog_name))
  402.           , "/=")), fs1);
  403.             if (same_signature(neq, prog_name) ) {
  404.                 exists = TRUE;
  405.                 break;
  406.             }
  407.         ENDFORSET(fs1);
  408.         if (exists) {
  409.             /* create body of corresponding inequality, whose implicit spec.
  410.              * was introduced with the spec. of equality.
  411.              */
  412.             neq_node = new_not_equals(neq, prog_name);
  413.             eq_node  = copy_node(node);
  414.             make_insert_node(node, tup_new1((char *) eq_node), neq_node);
  415.         }
  416.     }
  417. }
  418.  
  419. void process_subprog_body(Node node, Symbol prog_name) /*;process_subprog_body*/
  420. {
  421.     Node    decl_node, stats_node, handler_node;
  422.     int      has_return;
  423.  
  424.     has_return_stk = tup_with(has_return_stk, (char *)FALSE);
  425.  
  426.     decl_node  = N_AST2(node);
  427.     stats_node = N_AST3(node);
  428.     handler_node = N_AST4(node);
  429.  
  430.     lab_init();
  431.     adasem(decl_node);
  432.     adasem(stats_node);
  433.     adasem(handler_node);
  434.     lab_end();            /* Validate goto statements in subprogram*/
  435.  
  436.     has_return = (int) tup_frome(has_return_stk);
  437.  
  438.     if (NATURE(prog_name) == na_function && !has_return)
  439. #ifdef ERRNUM
  440.         errmsgn(378, 32, node);
  441. #else
  442.         errmsg("Missing RETURN statement in function body", "6.5", node);
  443. #endif
  444.  
  445.     check_incomplete_decls(prog_name, node);
  446. }
  447.  
  448. Node new_not_equals(Symbol neq, Symbol eq)                /*;new_not_equals*/
  449. {
  450.     /* Build the tree for the body of an implicitly defined inequality op.
  451.      * This is a prime candidate for on-line expansion later on.
  452.      */
  453.  
  454.     Node    node, id_node, arg1, arg2, a1, a2;
  455.     Node    call_node, not_node, ret_node, stat_node;
  456.     Tuple    sig, tup;
  457.  
  458.     node = node_new(as_subprogram_tr);
  459.     sig = SIGNATURE(neq);
  460.     arg1 = (Node) sig[1];
  461.     arg2 = (Node) sig[2];
  462.     a1 = (Node) new_name_node((Symbol) arg1);
  463.     a2 = (Node) new_name_node((Symbol) arg2);
  464.     tup = tup_new(2);
  465.     tup[1] = (char *) a1;
  466.     tup[2] = (char *) a2;
  467.     call_node = new_call_node(eq, tup, symbol_boolean);
  468.     not_node = new_unop_node(symbol_not, call_node, symbol_boolean);
  469.     id_node = new_name_node(neq);
  470.     ret_node = node_new(as_return);
  471.     N_AST1(ret_node) = not_node;    /* return not(arg1 = arg2)*/
  472.     N_AST2(ret_node) = id_node;
  473.     N_AST3(ret_node) = new_number_node(0);        /* from top level */
  474.     /*
  475.  * Note that stat_node is N_AST1 so is because the node is as_subprogram_tr
  476.  * which has the stat_node is N_AST1 instead of N_AST3 as it is for
  477.  * as_subprogram.
  478.  */
  479.     stat_node = new_statements_node(tup_new1((char *) ret_node));
  480.     N_AST1(node) = stat_node;
  481.     N_AST2(node) = OPT_NODE;
  482.     N_UNQ(node) = neq;        /* ignore formals, etc .*/
  483.     N_AST4(node) = OPT_NODE;
  484.  
  485.     return node;
  486. }
  487.  
  488. Tuple process_formals(Symbol scope, Tuple form_list,int newi)
  489.                                                         /*;process_formals*/
  490. {
  491.     /* This     is called to process  formal parameters of a procedure spec. or
  492.      * entry spec.
  493.      * The flag -newi- indicates whether this is the first time the object is
  494.      * seen. For  an entry or  subprogram declaration,  newi is true; for an
  495.      * accept  statement it is  false. For a  subprogram body it  depends on
  496.      * whether a separate specification was provided.
  497.      */
  498.  
  499.     Tuple    new_form_list, t, tup;
  500.     int        in_out, nat;
  501.     Node    opt_init;
  502.     Symbol    type_mark, form_name, f_nam;
  503.     char    *form_id;
  504.     int        i;
  505.     Fortup    ft1, ft2;
  506.     char    *id;
  507.  
  508.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : process_formals");
  509.  
  510.     new_form_list = tup_new(0);
  511.  
  512.     /* Initialize -declared- map for new scope. */
  513.  
  514.     if (DECLARED(scope) == (Declaredmap)0)
  515.         DECLARED(scope) = dcl_new(0);
  516.     newscope(scope);
  517.     nat = NATURE(scope);
  518.     NATURE(scope) = na_void;
  519.     FORTUP(t = (Tuple), form_list, ft1);
  520.         form_id = t[1];
  521.         in_out = (int) t[2];
  522.         type_mark = (Symbol)t[3];
  523.         opt_init = (Node) t[4];
  524.  
  525.         form_name = find_new(form_id);
  526.         /* formals parameters cannot have an incomplete type. They can
  527.          * have an incomplete private type however.
  528.          */
  529.         if (TYPE_OF(type_mark) == symbol_incomplete) {
  530. #ifdef ERRNUM
  531.             id_errmsgn(379, type_mark, 5, current_node);
  532. #else
  533.             errmsg_id("Invalid use of incomplete type %", type_mark,
  534.               "3.8.1", current_node);
  535. #endif
  536.         }
  537.         TYPE_OF(form_name) = type_mark;
  538.         default_expr(form_name)  = (Tuple) opt_init;
  539.         if (opt_init != OPT_NODE) {
  540.             adasem(opt_init);
  541.             normalize(type_mark, opt_init);
  542.         }
  543.         ORIG_NAME(form_name) = form_id;
  544.  
  545.         if (opt_init != OPT_NODE && newi && in_out != na_in) {
  546. #ifdef ERRNUM
  547.             errmsgn(380, 381, current_node);
  548. #else
  549.             errmsg("default initialization only allowed for IN parameters",
  550.               "6.1", current_node);
  551. #endif
  552.             opt_init = OPT_NODE;
  553.         }
  554.  
  555.         /* Assignable parameters must not appear in functions.*/
  556.         if ( in_out != na_in && (nat==na_function || nat==na_function_spec )) {
  557. #ifdef ERRNUM
  558.             str_errmsgn(382, nature_str(in_out), 32, current_node);
  559. #else
  560.             errmsg_str("functions cannot have % parameters ",
  561.               nature_str(in_out), "6.5", current_node);
  562. #endif
  563.         }
  564.  
  565.         TO_XREF(form_name);
  566.         new_form_list = tup_with(new_form_list, (char *) form_name);
  567.     ENDFORTUP(ft1);
  568.     FORTUPI(t = (Tuple), form_list, i, ft1);
  569.         /* at end of formal part, set mode of formal parameters */
  570.         form_id = t[1];
  571.         in_out = (int) t[2];
  572.         form_name = (Symbol) new_form_list[i];
  573.         NATURE(form_name) = in_out;
  574.     ENDFORTUP(ft1);
  575.  
  576.     NATURE(scope) = nat;
  577.     popscope();
  578.     if (newi)
  579.         return new_form_list;
  580.     else {        /* Verify that redeclaration matches. */
  581.         FORTUPI(tup = (Tuple), form_list, i, ft2);
  582.             id= tup[1];
  583.             in_out = (int) tup[2];
  584.             type_mark = (Symbol) tup[3];
  585.             opt_init = (Node) tup[4];
  586.             f_nam = (Symbol) (SIGNATURE(scope))[i];
  587.             if (
  588. #ifdef TBSN
  589.             -- skip this failed since original_name null even though had right
  590.             symbol     ds 1 aug
  591.             strcmp(id, original_name(f_nam)) != 0  ||
  592. #endif
  593.             in_out != NATURE(f_nam) || type_mark != TYPE_OF(f_nam) ) {
  594.                 /* missing conformance on init. */
  595. #ifdef ERRNUM
  596.                 errmsgn(383, 205, current_node);
  597. #else
  598.                 errmsg("Declaration does not match previous specification",
  599.                   "6.3.1", current_node);
  600. #endif
  601.             }
  602.         ENDFORTUP(ft2);
  603.         return SIGNATURE(scope);
  604.     }
  605. }
  606.  
  607. static Tuple derived_formals(Symbol scope, Tuple form_list) /*;derived_formals*/
  608. {
  609.     /* build list of formals for derived subprograms.
  610.      * No semantic checks necessary
  611.      */
  612.  
  613.     Tuple new_form_list, t;
  614.     Symbol form_name, type_mark;
  615.     char *form_id;
  616.     int  in_out;
  617.     Node opt_init;
  618.     Fortup ft1;
  619.  
  620.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : derived_formals");
  621.  
  622.     new_form_list = tup_new(0);
  623.  
  624.     /* Initialize -declared- map for new scope. */
  625.     DECLARED(scope) = dcl_new(0);
  626.  
  627.     newscope(scope);
  628.  
  629.     FORTUP(t = (Tuple), form_list, ft1);
  630.         form_id = t[1];
  631.         in_out = (int) t[2];
  632.         type_mark = (Symbol)t[3];
  633.         opt_init = (Node) t[4];
  634.  
  635.         form_name = find_new(form_id);
  636.  
  637.         NATURE(form_name) = in_out;
  638.         TYPE_OF(form_name) = type_mark;
  639.         default_expr(form_name)  = (Tuple) opt_init;
  640.         ORIG_NAME(form_name) = form_id;
  641.  
  642.         new_form_list = tup_with(new_form_list, (char *)form_name);
  643.     ENDFORTUP(ft1);
  644.     popscope();
  645.  
  646.     return(new_form_list);
  647. }
  648.  
  649. void reprocess_formals(Symbol name, Node formals_node)    /*;reprocess_formals */
  650. {
  651.     /* check conformance of subprogram specifications given in spec and body.*/
  652.  
  653.     Node     old_formals_node, old_node, new_node, old_id_list, type_node,
  654.         init_node;
  655.     Symbol     formal, type_mark;
  656.     Tuple    old_list, new_list;
  657.     char    *id;
  658.     int        i;
  659.  
  660.     old_formals_node = (Node) formal_decl_tree(name);
  661.     if (!conform(formals_node, old_formals_node)) {
  662.         conformance_error(formals_node);
  663.         return;
  664.     }
  665.  
  666.     old_list = N_LIST(old_formals_node);
  667.     new_list = N_LIST(formals_node);
  668.     for (i = 1; i <= tup_size(old_list); i++) {
  669.         old_node = (Node) old_list[i];
  670.         new_node = (Node) new_list[i];
  671.         old_id_list = N_AST1(old_node);
  672.         type_node = N_AST3(new_node);
  673.         type_mark = find_type(type_node);
  674.         init_node = N_AST4(new_node);
  675.         id = N_VAL((Node)N_LIST(old_id_list)[1]);
  676.         formal = dcl_get(DECLARED(name), id);
  677.         if (type_mark != TYPE_OF(formal)) {
  678.             conformance_error(type_node);
  679.             return;
  680.         }
  681.         if (init_node != OPT_NODE) {
  682.             adasem(init_node);
  683.             normalize(type_mark, init_node);
  684.         }
  685.         if (!same_expn(init_node, (Node)default_expr(formal))) {
  686.             conformance_error(init_node);
  687.             return;
  688.         }
  689.     }
  690. }
  691.  
  692. void normalize(Symbol context_type, Node expn)                /*;normalize*/
  693. {
  694.     /* This procedure performs type resolution (as in check_type), without
  695.      * constant folding.
  696.      */
  697.  
  698.     Set types, otypes;
  699.     Symbol t, old_context;
  700.     Forset    fs1;
  701.  
  702.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  normalize");
  703.  
  704.     N_TYPE(expn) = symbol_any;        /*By default.*/
  705.     fold_context = FALSE; /* to inhibit constant folding elsewhere.*/
  706.     noop_error = FALSE;
  707.  
  708.     resolve1(expn);        /* Bottom-up pass.*/
  709.  
  710.     if (noop_error) {
  711.         noop_error = FALSE;    /* error emitted already*/
  712.         return;
  713.     }
  714.  
  715.     types = N_PTYPES(expn);
  716.     old_context = context_type;
  717.     if (in_type_classes(context_type)) {
  718.         /* Keep only those that belong to this class.*/
  719.         otypes = set_copy(types);
  720.         types = set_new(0);
  721.         FORSET(t = (Symbol), otypes, fs1);
  722.             if (compatible_types(t, context_type))
  723.                 types = set_with(types, (char *) t);
  724.         ENDFORSET(fs1);
  725.         set_free(otypes);
  726.  
  727.         if (set_size(types) > 1) {
  728.             /* May be overloaded operator: user_defined one hides predefined.*/
  729.             /* types -:= univ_types */
  730.             otypes = set_copy(types); 
  731.             types = set_new(0);
  732.             FORSET(t = (Symbol), otypes, fs1);
  733.                 if (t != symbol_universal_integer && t != symbol_universal_real)
  734.                     types = set_with(types, (char *)t);
  735.             ENDFORSET(fs1);
  736.             set_free(otypes);
  737.         }
  738.  
  739.         if (set_size(types) == 1) {
  740.             context_type = (Symbol) set_arb (types );
  741.             set_free(types);
  742.         }
  743.         else {
  744.             type_error(set_new1((char *) symbol_any), context_type, 
  745.                 set_size(types), expn);
  746.             N_TYPE(expn) = symbol_any;
  747.             set_free(types);
  748.             fold_context = TRUE;
  749.             return;
  750.         }
  751.     }
  752.     resolve2(expn, context_type);
  753.     fold_context = TRUE;
  754.  
  755.     if (noop_error) {
  756.         noop_error = FALSE;    /* error emitted already*/
  757.         return;
  758.     }
  759.     /* Now emit a constraint qualification if needed.*/
  760.     if (! in_type_classes(old_context) ) {
  761.         apply_constraint(expn, context_type);
  762.     }
  763. }
  764.  
  765. int conform(Node exp1, Node exp2)                    /*;conform*/
  766. {
  767.     /* Verify that two trees corresponding to two expressions are conformant,
  768.      * according to 6.2.1. This procedure is called after ascertaining that
  769.      * the trees denote the same entities. We now verify that their lexical
  770.      * structure is conformant.
  771.      */
  772.  
  773.     Tuple    l1, l2;
  774.     Node   sel_node, pfx1, pfx2, sel1, sel2;
  775.     int    i, nk;
  776.     char  * id1;
  777.  
  778.     switch (N_KIND(exp1)) {
  779.     case (as_simple_name):
  780.         if (N_KIND(exp2) == as_simple_name)
  781.             return streq(N_VAL(exp1), N_VAL(exp2));
  782.         else if (N_KIND(exp2) == as_selector) {
  783.             sel_node = N_AST2(exp2);
  784.             id1 = N_VAL(exp1);
  785.             return !in_op_designators(id1) && streq(id1, N_VAL(sel_node));
  786.         }
  787.         else if (N_KIND(exp2) == as_qual_range) {
  788.             /* possible if first occurrence had private type.*/
  789.             return conform(exp1, N_AST1(exp2));
  790.         }
  791.         else
  792.             return FALSE;
  793.     case (as_mode):
  794.         return(N_VAL(exp1) == N_VAL(exp2));   /* mode is integer in C version */
  795.     case (as_int_literal):
  796.         return (N_KIND(exp2) == as_int_literal
  797.           && const_eq(adaval(symbol_universal_integer, N_VAL(exp1)),
  798.           adaval(symbol_universal_integer, N_VAL(exp2)) ));
  799.     case (as_real_literal):
  800.         return (N_KIND(exp2) == as_real_literal
  801.           && const_eq(adaval(symbol_universal_real, N_VAL(exp1)),
  802.           adaval(symbol_universal_real, N_VAL(exp2)) ) );
  803.     case (as_string_literal):
  804.         return(N_KIND(exp2) == as_string_literal
  805.           && streq(N_VAL(exp1), N_VAL(exp2)));
  806.     case (as_selector):
  807.         pfx1 = N_AST1(exp1);
  808.         sel1 = N_AST2(exp1);
  809.         if (N_KIND(exp2) == as_simple_name )
  810.             return (conform(exp2, exp1));
  811.         else if (N_KIND(exp2) == as_selector ) {
  812.             pfx2  = N_AST1(exp2);
  813.             sel2  = N_AST2(exp2);
  814.             return (conform(pfx1, pfx2) && streq(N_VAL(sel1), N_VAL(sel2)));
  815.         }
  816.         else
  817.             return FALSE;
  818.         break;
  819.     default:
  820.         if (N_KIND(exp1) != N_KIND(exp2) )
  821.             return FALSE;
  822.         else {
  823.             /* if is_tuple(a1 := N_AST(exp1)) then 
  824.                *    (for i in [1..#a1])
  825.                 *        if not conform(a1(i), a2(i)) then return FALSE; end;
  826.                *    end for;
  827.                */
  828.             nk = N_KIND(exp1);
  829.             if (N_AST1_DEFINED(nk) && N_AST1(exp1) != (Node)0) {
  830.                 if (!conform(N_AST1(exp1), N_AST1(exp2)))
  831.                     return FALSE;
  832.                 if (N_AST2_DEFINED(nk) && N_AST2(exp1) != (Node)0) {
  833.                     if (!conform(N_AST2(exp1), N_AST2(exp2)))
  834.                         return FALSE;
  835.                     if (N_AST3_DEFINED(nk) && N_AST3(exp1) != (Node)0) {
  836.                         if (!conform(N_AST3(exp1), N_AST3(exp2)))
  837.                             return FALSE;
  838.                         if (N_AST4_DEFINED(nk) &&N_AST4(exp1) != (Node)0) {
  839.                             if (!conform(N_AST4(exp1), N_AST4(exp2)))
  840.                                 return FALSE;
  841.                         }
  842.                     }
  843.                 }
  844.             }
  845.             /* if is_tuple(l1 := N_LIST(exp1)) then
  846.                *    if #l1 != #(l2 := N_LIST(exp2) ? [])) then 
  847.                *        return FALSE;
  848.                *     else
  849.                *       (for i in [1..#l1]))
  850.                *          if not conform(l1(i), l2(i)) then
  851.                *        return FALSE;
  852.                *          end if;
  853.                *    end if;
  854.                * end if;
  855.                  */
  856.             if (N_LIST_DEFINED(nk))
  857.                 l1 = N_LIST(exp1);
  858.             else
  859.                 l1 = (Tuple) 0;
  860.             if (l1 != (Tuple)0) {
  861.                 if (N_LIST_DEFINED(N_KIND(exp2)))
  862.                     l2 = N_LIST(exp2);
  863.                 else
  864.                     l2 = (Tuple) 0;
  865.                 if (l2 == (Tuple)0 || tup_size(l1) != tup_size(l2) )
  866.                     return FALSE;
  867.                 for (i = 1; i <= tup_size(l1); i++) {
  868.                     if (!conform((Node)l1[i], (Node)l2[i]))
  869.                         return FALSE;
  870.                 }
  871.             }
  872.             return TRUE;  /* AST and LIST match. */
  873.         }
  874.     } /* end switch */
  875. }
  876.  
  877. void call_statement(Node node) /*;call_statement*/
  878. {
  879.     /* This procedure resolves call statements. Syntactically the node is
  880.      * a name, possibly selected and indexed.
  881.      * These statements can have one of the following meanings :
  882.      * a) Procedure call.
  883.      * b) entry call .
  884.  
  885.      * Procedure and entry calls are handled by first resolving the name, and
  886.      * then type-checking the  argument list. Complications arise for parame-
  887.      * terless procedures and entries, and for parameterless entries in entry
  888.      * entry  families. In those  cases, this procedure reformats the name by
  889.      * appending an empty argument list.
  890.      */
  891.  
  892.     Node    c_node, arg_list;
  893.     int        nk;
  894.  
  895.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : call_statement");
  896.  
  897.     c_node = N_AST1(node);
  898.     if (N_KIND(c_node) == as_call_unresolved) {
  899.         /* Rebuild call node: proc name, arg_list. */
  900.         /* Next, do N_AST(node) = N_AST(c_node) */
  901.         nk = N_KIND(node);
  902.         if (N_AST1_DEFINED(nk)) N_AST1(node) = N_AST1(c_node);
  903.         if (N_AST2_DEFINED(nk)) N_AST2(node) = N_AST2(c_node);
  904.         if (N_AST3_DEFINED(nk)) N_AST3(node) = N_AST3(c_node);
  905.         if (N_AST4_DEFINED(nk)) N_AST4(node) = N_AST4(c_node);
  906.     }
  907.     else if (N_KIND(c_node) == as_simple_name || N_KIND(c_node)==as_selector) {
  908.         /* Parameterless procedure, */
  909.         /* qualified name of entry.  */
  910.         arg_list = node_new(as_list); /* add empty argument list. */
  911.         N_LIST(arg_list) = tup_new(0);
  912.         N_AST1(node) = c_node;
  913.         N_AST2(node) = arg_list;
  914.     }
  915.     else {
  916. #ifdef ERRNUM
  917.         errmsgn(384, 3, node);
  918. #else
  919.         errmsg("Invalid statement: not procedure or entry call", "5.1", node);
  920. #endif
  921.         return;
  922.     }
  923.     proc_or_entry(node);
  924. }
  925.  
  926. static void proc_or_entry(Node node)                    /*;proc_or_entry*/
  927. {
  928.     /* Process procedure calls, entry calls, and calls to members of
  929.      * entry families.
  930.      * The statement :           name(args);
  931.      * can have 3 meanings :
  932.      * a) It can be a procedure call.
  933.      * b) It can be an entry call.
  934.      * c) -name- can be the name of an entry family, and -args- an index
  935.      * into that family. This is recognized by the fact that the type of
  936.      * -name- is an array type.
  937.      * In the first two cases, we must type-check and format the argument
  938.      * list. In the last one, we must emit a parameterless entry call.
  939.  
  940.      * If the statement has the format :    name(arg)(args);
  941.  
  942.      * then it can only be a call  with parameters to an element of an
  943.      * entry family.
  944.      */
  945.  
  946.     Node    obj_node, arg_list, a_node;
  947.     Symbol    obj_name, entr;
  948.     Fortup    ft1;
  949.  
  950.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  proc_or_entry");
  951.  
  952.     obj_node = N_AST1(node);
  953.     arg_list = N_AST2(node);
  954.  
  955.     adasem(obj_node);
  956.     /* Perform name resolution on argument list.*/
  957.     FORTUP(a_node = (Node), N_LIST(arg_list), ft1);
  958.         adasem(a_node);
  959.     ENDFORTUP(ft1);
  960.  
  961.     if (N_KIND(obj_node) == as_simple_name || N_KIND(obj_node) == as_selector) {
  962.         find_old(obj_node);
  963.         obj_name = N_UNQ(obj_node);
  964.  
  965.         /* Probably indicated in a different way */
  966.         if (N_KIND(obj_node) != as_simple_name) {
  967.             entry_call(node);
  968.         }
  969.         else if (obj_name != (Symbol)0  && NATURE(obj_name) == na_entry_family)
  970.             /* entry family called within task body, without qualified name.*/
  971.             entry_call(node);
  972.         else if (N_OVERLOADED(obj_node)) {
  973.             check_type(symbol_none, node);
  974.  
  975.             entr = N_UNQ(obj_node);
  976.             if (entr != (Symbol)0 && NATURE(entr) == na_entry) {
  977.                 Symbol task_name;
  978.                 task_name = SCOPE_OF(entr);
  979.                 if (is_task_type(task_name))
  980.                     task_name = dcl_get(DECLARED(task_name), "current_task");
  981.                 N_KIND(obj_node) = as_entry_name;
  982.                 N_AST1(obj_node) = new_name_node(task_name);
  983.                 N_AST2(obj_node) = new_name_node(entr);
  984.                 N_AST3(obj_node) = OPT_NODE;
  985.             }
  986.             if (N_KIND(node) != as_call && N_KIND(node) != as_ecall) {
  987. #ifdef ERRNUM
  988.                 errmsgn(385, 386, node);
  989. #else
  990.                 errmsg("Invalid procedure or entry call", "6.5, 9.5", node);
  991. #endif
  992.             }
  993.  
  994.         }
  995.         else {
  996.         /* If the name was undeclared, an error message was emitted
  997.          * already. We can detect this case by the fact that the identifier
  998.          * has type -any-.
  999.          */
  1000.             if (TYPE_OF(obj_name) != symbol_any ) {
  1001. #ifdef ERRNUM
  1002.                 errmsgn(387, 3, node);
  1003. #else
  1004.                 errmsg("Invalid statement", "5.1", node);
  1005. #endif
  1006.             }
  1007.             else {
  1008.             /* Make up a dummy symbol table entry, so that subsequent uses
  1009.              * of it have a chance of looking plausible.
  1010.              */
  1011.                 NATURE(obj_name) = na_procedure;
  1012.                 {    
  1013.                     int i, n; 
  1014.                     Tuple tup;
  1015.                     n = tup_size(N_LIST(arg_list));
  1016.                     tup = tup_new(n);
  1017.                     for (i = 1; i <= n; i++)
  1018.                         tup[i] = (char *) symbol_any_id;
  1019.                     SIGNATURE(obj_name) = tup;
  1020.                 }
  1021.                 TYPE_OF(obj_name) = symbol_none;
  1022.                 OVERLOADS(obj_name) = set_new1((char *) obj_name);
  1023.             }
  1024.         }
  1025.     }
  1026.     else {
  1027.         /* Case of an entry family call with parameters. */
  1028.         find_old(obj_node);
  1029.         if (N_TYPE(obj_node) == symbol_any || N_KIND(obj_node) != as_index ) {
  1030. #ifdef ERRNUM
  1031.             errmsgn(388, 321, node);
  1032. #else
  1033.             errmsg("Invalid call", "9.5", node);
  1034. #endif
  1035.         }
  1036.         else entry_call(node);
  1037.     }
  1038. }
  1039.  
  1040.  
  1041. Symbol chain_overloads(char *id, int new_nat, Symbol new_typ, Tuple new_sig,
  1042.   Symbol parent_subp, Node formals_node) /*;chain_overloads*/
  1043. {
  1044.     /* Insert procedure, function, or enumeration literal into the current
  1045.      * symbol table. Because these names can be overloaded, each set of
  1046.      * overloaded names visible in the current scope is held in the
  1047.      * -overload- attribute of the corresponding identifier.
  1048.      * If there is no actual overload, the unique name is generated as for
  1049.      * any other identifier. Otherwise, successive overloads in the same
  1050.      * scope are given an additional arbitrary suffix to distinguish them
  1051.      * one from the other.
  1052.      * The overloaded name in inserted in the current scope.
  1053.      */
  1054.  
  1055.     int        old_nat, n;
  1056.     Symbol    new_name, seen, name;
  1057.     Set        current_overload;
  1058.     Forset    fs1;
  1059.  
  1060.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  chain_overloads");
  1061.  
  1062.     new_name = sym_new(new_nat);
  1063.  
  1064.     seen = dcl_get(DECLARED(scope_name), id);
  1065.     if (seen== (Symbol)0) {
  1066.         /* First occurrence in this scope. Define therein, and make visible
  1067.          * if scope is visible part of package specification.
  1068.          */
  1069.         dcl_put_vis(DECLARED(scope_name), id, new_name,
  1070.           NATURE(scope_name) == na_package_spec);
  1071.         ORIG_NAME(new_name) = id;
  1072.         new_over_spec(new_name, new_nat, new_typ, new_sig,
  1073.           parent_subp, formals_node);
  1074.     }
  1075.     else {
  1076.         /* Name already appears in current scope. One of the following
  1077.          * may be the case :
  1078.          * a) It is a redeclaration, either because a non-overloaded
  1079.          * instance of that id exists, or because an object with the
  1080.          * same signature has already been declared : indicate error.
  1081.          * b) It is the body of a function or procedure, whose specs
  1082.          * have already been seen. Update the corresponding entry.
  1083.          * c) It is a new object. Generate a new name, and make entry
  1084.          * for it.
  1085.          * d) It is a redeclaration of a derived subprogram. in that case
  1086.          * the derived subprogram becomes inaccessible.
  1087.          * e) If it is a derived subprogram, and there is an explicit user
  1088.          * defined one already, the derived one is discarded. 
  1089.          */
  1090.         if (!can_overload(seen)) {
  1091. #ifdef ERRNUM
  1092.             str_errmsgn(389, id, 390, current_node);
  1093. #else
  1094.             errmsg_str("Redeclaration of identifier %", id, "8.3, 8.4",
  1095.               current_node);
  1096. #endif
  1097.             return seen;
  1098.         }
  1099.         else {
  1100.             current_overload =  set_copy(OVERLOADS(seen));
  1101.             /* If the current scope is a private part, make sure the visible
  1102.              * declaration has been saved, before any modification of overloads
  1103.              * set.
  1104.              */
  1105.             if ((scope_name != symbol_standard0) &&
  1106.               (NATURE(scope_name) == na_private_part ||
  1107.               NATURE(scope_name) == na_package) &&
  1108.               private_decls_get((Private_declarations)
  1109.               private_decls(scope_name), seen) == (Symbol)0 ) {
  1110.                 private_decls_put((Private_declarations)
  1111.                   private_decls(scope_name), seen);
  1112.             }
  1113.         }
  1114.         FORSET(name = (Symbol), current_overload, fs1);
  1115.             if  (same_sig_spec(name, new_sig)
  1116.               && same_type(TYPE_OF(name), new_typ) ) {
  1117.                 /* A homograph of  the current declaration exists in the
  1118.                  * scope. This is  permissible only if  one or  both are
  1119.                  * implicit declarations of derived subprogram or prede-
  1120.                  * fined operation. The latter  do not appear in Ada/Ed,
  1121.                  * and we only need to consider derived subprograms.
  1122.                  */
  1123.                 if (is_derived_subprogram(name) ) {
  1124.                     /* An explicit declaration redefines an implicitly
  1125.                      * derived subprogram. Make the later unreachable.
  1126.                      */
  1127.                     OVERLOADS(seen) = set_less(OVERLOADS(seen), (char *) name);
  1128.                     /* next line incorrect: code gen. needs to know parent */
  1129.                     /* ALIAS(name) = (Symbol) 0; */
  1130.                 }
  1131.                 else if (parent_subp != (Symbol)0 
  1132.                   && streq(id, ORIG_NAME(parent_subp) )) {
  1133.                     /* New declaration is derived subprogram.*/
  1134.                     new_name = named_atom(id);
  1135.                     if (new_nat != na_literal) {
  1136.                         /* A derived subprogram is hidden by any other homograph
  1137.                          * but may itself be further derived. Insert in symbol
  1138.                          * table as new entity, which is only retrievable when
  1139.                          * iterating over declared map. A derived literal is
  1140.                          * also hidden by other declarations, but still exists
  1141.                          * as a literal of the type. It is inserted in symbol
  1142.                          * table but not in declared. 
  1143.                           */
  1144.                         dcl_put(DECLARED(scope_name), strjoin(id, newat_str()),
  1145.                            new_name);
  1146.                     }
  1147.                     new_over_spec(new_name, new_nat, new_typ, new_sig,
  1148.                       parent_subp, formals_node);
  1149.                     ORIG_NAME(new_name) = id;
  1150.                     return new_name;
  1151.                 }
  1152.                 else {
  1153.                     n = NATURE(name);
  1154.                     if ((n == na_procedure_spec
  1155.                       && new_nat == na_procedure)
  1156.                       || (n == na_function_spec && new_nat == na_function)) {
  1157.                         /* Subprogram body whose spec was already seen.*/
  1158.                         NATURE(name) = new_nat;
  1159.                         /* Verify conformance of formal param declarations.*/
  1160.                         reprocess_formals(name, formals_node);
  1161.                         return name;
  1162.                     }
  1163.                     else {
  1164. #ifdef ERRNUM
  1165.                         str_errmsgn(391, id, 392, current_node);
  1166. #else
  1167.                         errmsg_str("invalid declaration of homograph %",
  1168.                           id, "8.3(17)", current_node);
  1169. #endif
  1170.                         return name;
  1171.                     }
  1172.                 }
  1173.             }
  1174.         ENDFORSET(fs1);
  1175.         /* If we fall through, this is a new entity. Build its symbol table
  1176.          * entry, and add it to the overload set already seen. 
  1177.          * As declared(scope)(id) is already defined, we enter the entity in
  1178.          * the declared map using an arbitrary string. The new entity  will
  1179.          * always be retrieved through overload(seen).
  1180.          * The name of the subprogram becomes hidden until the end of the spec.
  1181.          * In particular, it cannot be used inside the formal part. 
  1182.          */
  1183.         /* add identifier name to result of newat_str to create a unique
  1184.          * anonymous entity which will not conflict with names generated
  1185.          * by anonymous_type
  1186.          */
  1187.         new_name = named_atom(id);
  1188.         dcl_put_vis(DECLARED(scope_name), strjoin(id, newat_str()), new_name,
  1189.           NATURE(scope_name) == na_package_spec);
  1190.         old_nat = NATURE(seen);
  1191.         NATURE(seen) = na_void;
  1192.         new_over_spec(new_name, new_nat, new_typ, new_sig,
  1193.           parent_subp, formals_node);
  1194.         NATURE(seen) = old_nat;
  1195.         OVERLOADS(seen) = set_with(OVERLOADS(seen) , (char *) new_name);
  1196.         ORIG_NAME(new_name) = id;
  1197.     }
  1198.     return new_name;
  1199. }
  1200.  
  1201. int can_overload(Symbol name)  /*;can_overload*/
  1202. {
  1203.     int n;
  1204.     n = NATURE(name);
  1205.     return (n == na_procedure_spec || n == na_function_spec || n == na_op
  1206.       || n == na_function || n == na_procedure || n == na_entry
  1207.       || n == na_literal);
  1208. }
  1209.  
  1210. static void new_over_spec(Symbol name, int nat, Symbol typ, Tuple sig,
  1211.   Symbol parent_subp, Node formals_node) /*;new_over_spec*/
  1212. {
  1213.     /* Place in symbol table maps the specification of a new overloadable
  1214.      * object .
  1215.      */
  1216.  
  1217.     Symbol    arg_type;
  1218.  
  1219.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  new_over_spec");
  1220.  
  1221.     /* Apply the special checks on redefinitions of equality.*/
  1222.  
  1223.     NATURE(name) = nat;
  1224.     TYPE_OF(name) = typ;
  1225.     SCOPE_OF(name) = scope_name;
  1226.     OVERLOADS(name) = set_new1((char *) name);
  1227.     if (nat == na_literal)    SIGNATURE(name) = tup_new(0);
  1228.  
  1229.     /* If the subprograms have the same name but the signatures have different 
  1230.      * types or the subprograms have differing types it is a derived subprogram 
  1231.      * otherwise it is a renaming of a subprogram.
  1232.      */
  1233.     else if (parent_subp != (Symbol) 0 && 
  1234.       streq(ORIG_NAME(name), ORIG_NAME(parent_subp)) &&
  1235.       (!same_sig_spec(parent_subp, sig) || 
  1236.       TYPE_OF(name) != TYPE_OF(parent_subp)))
  1237.         SIGNATURE(name) = derived_formals(name, sig);
  1238.     else {
  1239.         SIGNATURE(name) = process_formals(name, sig, TRUE);
  1240.         formal_decl_tree(name) = (Symbol) formals_node;
  1241.     }
  1242.     if (streq(original_name(name) , "=")) {
  1243.         /* introduce the implicit "/=" as well.*/
  1244.         chain_overloads("/=", na_function, typ, sig, (Symbol)0, OPT_NODE);
  1245.         arg_type = TYPE_OF((Symbol)SIGNATURE(name)[1]);
  1246.         if (!is_limited_type(arg_type) && parent_subp == (Symbol)0) {
  1247.             /* an equality operator can only be defined on limited types
  1248.              * unless it is introduced by a renaming declaration or derivation
  1249.              */
  1250. #ifdef ERRNUM
  1251.             errmsgn(393, 54, current_node);
  1252. #else
  1253.             errmsg("= can only be defined for limited types", "6.7",
  1254.               current_node);
  1255. #endif
  1256.         }
  1257.     }
  1258.     TO_XREF(name);
  1259. }
  1260.  
  1261. int same_signature(Symbol sub1, Symbol sub2) /*;same_signature*/
  1262. {
  1263.     /* Compare the signatures of two subprograms to determine whether
  1264.      * they hide each other. Two signatures are considered identical if
  1265.      * they have the same length, and the formals match in name and type.
  1266.      */
  1267.  
  1268.     int        i;
  1269.     Symbol    type1, type2;
  1270.     Tuple    old, newi;
  1271.  
  1272.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  same_signature");
  1273.  
  1274.     old = SIGNATURE(sub1);
  1275.     newi = SIGNATURE(sub2);
  1276.     if (old == newi) return TRUE;
  1277. #ifdef TBSN
  1278.     == how to translate is_tuple ?? ds 8 jun
  1279. else if (! is_tuple(old) ||  ! is_tuple(newi) ) {
  1280.     return FALSE;
  1281. }
  1282. #endif
  1283.     else if (tup_size(old) != tup_size(newi)) return FALSE;
  1284.     else {
  1285.         for (i = 1; i <= tup_size(old); i++) {
  1286.             type1 = (Symbol) old[i]; 
  1287.             type2 = (Symbol) newi[i];
  1288.             if (! same_type(TYPE_OF(type1), TYPE_OF(type2)) ) return FALSE;
  1289.         }
  1290.         return TRUE;
  1291.     }
  1292. }
  1293.  
  1294. int same_sig_spec(Symbol subp, Tuple spec) /*;same_sig_spec*/
  1295. {
  1296.     /* Compare the signature of a subprogram with the formals list of a
  1297.      * new subprogram specification.
  1298.      */
  1299.  
  1300.     Tuple    sig;
  1301.     Tuple    tup;
  1302.     int    i;
  1303.     Symbol    new_typ;
  1304.     Symbol    sym;
  1305.  
  1306.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  same_sig_spec");
  1307.  
  1308.     sig = SIGNATURE(subp);
  1309.  
  1310.     if (tup_size(sig) != tup_size(spec)) return FALSE;
  1311.     else {
  1312.         for (i = 1; i <= tup_size(sig); i++) {
  1313.             tup = (Tuple) spec[i];
  1314.             new_typ = (Symbol)tup[3];
  1315.             sym = (Symbol)(sig[i]);
  1316.             if (!same_type(TYPE_OF(sym), new_typ)) return FALSE;
  1317.         }
  1318.         return TRUE;
  1319.     }
  1320. }
  1321.  
  1322. int same_type(Symbol type1, Symbol type2) /*;same_type*/
  1323. {
  1324.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  same_type");
  1325.  
  1326.     return (base_type(type1) == base_type(type2) );
  1327. }
  1328.